Ham Radio 2000 #1/Ham Radio 2000.iso/ham2000/packet/p_aa4re/bb212src/bbyapp2.pas

Pascal/Delphi Source File | 1991-12-22 | 14.4 KB | 580 lines

(*===========================================================================*)
(* YAPP Protocol processor -- This is mostly Jeff's code                     *)
(*                                                                           *)
(*   Copyright 1986  Jeffry B. Jacobsen.  All rights reserved.               *)
(*   Copyright 1989 by H. Roy Engehausen.  All rights reserved.              *)
(*                                                                           *)
(*   This implements the YAPP(tm) binary transfer protocol (or at least      *)
(*   a subset OF the full protocol - this version does not include the       *)
(*   server commands FOR automated transfer.)                                *)
(*                                                                           *)
(*   This is a modified version OF the actual code used in YAPP FOR the      *)
(*   IBM PC AND compatibles.  Some lines have been deleted that handled      *)
(*   functions such as displaying the status OF the transfer, AND checking   *)
(*   FOR an abort from the keyboard.                                         *)
(*                                                                           *)
(*===========================================================================*)

FUNCTION waitready : BOOLEAN;

  VAR
    i         : BYTE;
    timer_set : BOOLEAN;

  BEGIN;

    waitready := false;
    timer_set := FALSE;

    REPEAT
      IF timer_set THEN
        BEGIN;

          IF timeout THEN           {timeout checks timer value which is}
            BEGIN;
              ptype := TM;          {decremented towards 0 every second }
              waitready := true;
              (* Next lines added by AA4RE for detection *)
              work_string := 'YAPP waitready =' + active_tcb^.i_data.str_data;
              set_dollar1_parm (@work_string);
              showmsg(13);          {error message display}
              (* End addition                            *)
              EXIT;
            END;

        END
      ELSE
        BEGIN;

          IF send_switch THEN
            i := send_unacked(TRUE)
          ELSE
            i := 0;

          send_switch := FALSE;

          IF i = 0 THEN
            BEGIN;
              timer_set := TRUE;
              IF (state = S) or (state = S1) THEN
                set_timer(20)             { 20 seconds to timeout}
              ELSE
                set_timer(120);           {120 seconds to timeout}
            END;

        END;

    UNTIL inready;              {inready checks FOR character ready at TNC}
  END;

PROCEDURE getpkstr;

  VAR
    i  : INTEGER;
    ch : CHAR;

  BEGIN
    IF waitready THEN EXIT;
    ch := recvchar;           {recvchar returns character from TNC}
    pklen := ORD(ch);
    IF (ptype = DT) AND (pklen = 0) THEN pklen := 256;
    IF (pklen = 0) THEN EXIT;
    FOR i := 1 to pklen DO
      BEGIN
        IF waitready THEN EXIT;
        ch := recvchar;
        pkbuff[i] := ch;
      END;
   END;

PROCEDURE getpack;

  VAR
    ch : CHAR;

  BEGIN
    ptype := UK;
    IF waitready THEN EXIT;
    ch := recvchar;

    CASE ch OF
      ACK:  BEGIN
            IF waitready THEN EXIT;
            ch := recvchar;
            CASE ORD(ch) OF
              1: ptype := RR;
              2: ptype := RF;
              3: ptype := AF;
              4: ptype := AT;
              5: ptype := CA;
              else;
              END;
            END;
      ENQ:  BEGIN
            IF waitready THEN EXIT;
            ch := recvchar;
            CASE ORD(ch) OF
              1: ptype := SI;
              2: ptype := RI;
              ELSE ptype := UU; {unimplemented command}
              END;
            END;
      SOH:  BEGIN
            ptype := HD;
            getpkstr;
            END;
      STX:  BEGIN
            ptype := DT;
            getpkstr;
            END;
      ETX:  BEGIN
            IF waitready THEN EXIT;
            ch := recvchar;
            IF (ORD(ch) = 1) THEN ptype := EF;
            END;
      EOT:  BEGIN
            IF waitready THEN EXIT;
            ch := recvchar;
            IF (ORD(ch) = 1) THEN ptype := ET;
            END;
      NAK:  BEGIN
            ptype := NR;
            getpkstr;
            END;
      CAN:  BEGIN
            ptype := CN;
            getpkstr;
            END;
      DLE:  BEGIN
            ptype := TX;
            getpkstr;
            END;
    ELSE
      BEGIN;
        (* Next lines added by AA4RE for better error explaination *)
        STR(ORD(ch), work_string);
        work_string := 'YAPP getpack (' + work_string + ')';
        set_dollar1_parm (@work_string);
        showmsg(13);          {error message display}
        work_string := 'YAPP getpack2 =' + active_tcb^.i_data.str_data;
        set_dollar1_parm (@work_string);
        (* End addition ------------------------------------------ *)
        showmsg(13);          {error message display}
      END;
    END; {case}
  END;


PROCEDURE Sendinit;

  BEGIN
    Sendinit_Count := 0;
    xmitstr(ENQ + #01);          {send string to TNC}
    getpack;
    CASE ptype OF
      TM : state := S1;
      RI : state := S;
      RR : state := SH;
      RF : state := SD;
      CN : state := C;
      NR : state := Start;
      TX : disppacket;
      ELSE BEGIN
           state := Abort;
           (* Next lines added by AA4RE for better error explaination *)
           STR(ORD(ptype), work_string);
           work_string := 'YAPP Sendinit (' + work_string + ')';
           set_dollar1_parm (@work_string);
           (* End addition ------------------------------------------ *)
           showmsg(13);          {error message display}
           END;
      END;
    END;

PROCEDURE Sendinit_retry;

  BEGIN
    Sendinit_Count := Sendinit_Count + 1;
    IF (Sendinit_Count > 6) THEN BEGIN
      state := Abort;
      showmsg(12);
      EXIT;
      END;
    xmitstr(ENQ + #01);
    getpack;
    CASE ptype OF
      TM : state := S1;
      RI : state := S;
      RR : state := SH;
      RF : state := SD;
      CN : state := C;
      NR : state := Start;
      TX : disppacket;
      ELSE BEGIN
           state := Abort;
           (* Next lines added by AA4RE for better error explaination *)
           STR(ORD(ptype), work_string);
           work_string := 'YAPP Sendinitretry (' + work_string + ')';
           set_dollar1_parm (@work_string);
           (* End addition ------------------------------------------ *)
           showmsg(13);
           END;
      END;
    END;

PROCEDURE Sendhdr;

  VAR
    stlen : byte;
    temp  : STRING;

  BEGIN
    STR(FILESIZE(pkfile^), temp);
    temp := search_arg + NUL + temp + NUL;
    xferhdr := temp;
    showheader;                          {display}
    stlen := length(temp);
    xmitstr(SOH + chr(stlen) + temp);
    getpack;
    CASE ptype OF
      RF : state := SD;
      CN : state := C;
      NR : state := Start;
      TX : disppacket;
      ELSE BEGIN
           state := Abort;
           IF (ptype = TM) THEN showmsg(12)
             ELSE
               BEGIN;
                 (* Next lines added by AA4RE for better error explaination *)
                 STR(ORD(ptype), work_string);
                 work_string := 'YAPP Sendhdr (' + work_string + ')';
                 set_dollar1_parm (@work_string);
                 (* End addition ------------------------------------------ *)
                 showmsg(13);
               END;
           END;
      END;
    END;

PROCEDURE Senddata;

  VAR
    bte     : byte;
    i,cnt   : INTEGER;
    temp    : ARRAY [-1..256] OF CHAR;
    ch      : CHAR;
    scancode: INTEGER;

  BEGIN
    IF inready THEN BEGIN     {we shouldnt be getting a packet   }
      getpack;                {unless they sent a Cancel or Text }
      IF (ptype = CN) THEN BEGIN
        state := C;
        EXIT;
        END
      ELSE IF (ptype = TX) THEN
        disppacket
      ELSE BEGIN
        WRITELN('Unexpected packet type during Send!');
        state := Abort;
        RUNERROR(yapp_error);
        END;
      END;
    cnt := 0;
    WHILE (not eof(pkfile^)) AND (cnt < bytes_per_block) DO
      BEGIN
      INC(cnt);
      read(pkfile^,bte);
      temp[cnt] := chr(bte);
      END;
    IF cnt <> 0 THEN
      BEGIN
(* modified to send as a block *)
      IF cnt = 256 THEN temp[0] := #0 ELSE temp[0] := CHR(cnt);
      temp[-1] := STX;

      send_tnc_data_ub(@temp, cnt + 2);
      END;

    send_switch := TRUE;

(* end mods *)

    IF cnt < bytes_per_block THEN state := SE;
    xfercnt := xfercnt + cnt;

    IF show_xmit_count > 0 THEN
      DEC(show_xmit_count)
    ELSE
      BEGIN;
        showbytes;
        show_xmit_count := 3;
      END;
  END;

PROCEDURE SendEOF;

  BEGIN
    showbytes;
    xmitstr(ETX + #01);
    getpack;
    CASE ptype OF
      AF : state := ST;
      TX : disppacket;
      ELSE BEGIN
           state := Abort;
           IF (ptype = TM) THEN showmsg(12)
             ELSE
               BEGIN;
                 (* Next lines added by AA4RE for better error explaination *)
                 STR(ORD(ptype), work_string);
                 work_string := 'YAPP Sendeof (' + work_string + ')';
                 set_dollar1_parm (@work_string);
                 (* End addition ------------------------------------------ *)
                 showmsg(13);
               END;
           END;
      END;
    END;

PROCEDURE SendEOT;

  BEGIN
    xmitstr(EOT + #01);
    getpack;
    CASE ptype OF
      AT : state := Start;  {Ack ok}
      TX : disppacket;
      ELSE state := Start;  {They sent AF - so dont worry about it}
    END;
    xferok := TRUE;
  END;

PROCEDURE Receive;

  BEGIN
    getpack;
    CASE ptype OF
      SI : BEGIN
           showmsg(1);
           xmitstr(ACK + #01);
           state := RH;
           END;
      CN : state := C;
      TX : disppacket;
      ELSE BEGIN
           state := Abort;
           IF (ptype = TM) THEN showmsg(12)
             ELSE
               BEGIN;
                 (* Next lines added by AA4RE for better error explaination *)
                 STR(ORD(ptype), work_string);
                 work_string := 'YAPP Receive (' + work_string + ')';
                 set_dollar1_parm (@work_string);
                 (* End addition ------------------------------------------ *)
                 showmsg(13);
               END;
           END;
      END;
end;

PROCEDURE rcvhdr;

var
  i : INTEGER;
  temp : line;

  BEGIN
    temp := '';
    getpack;
    CASE ptype OF
      HD : BEGIN
           FOR i := 1 to pklen
             DO temp := temp + pkbuff[i];
           xferhdr := temp;
           showheader;
           xmitstr(ACK + #02);
           state := RD;
           END;
      SI : state := RH;
      CN : state := C;
      ET : BEGIN
           xmitstr(ACK + #04);
           state := Start;
           END;
      TX : disppacket;
      ELSE BEGIN
           state := Abort;
           IF (ptype = TM) THEN showmsg(12)
             ELSE
               BEGIN;
                 (* Next lines added by AA4RE for better error explaination *)
                 STR(ORD(ptype), work_string);
                 work_string := 'YAPP Rcvhdr (' + work_string + ')';
                 set_dollar1_parm (@work_string);
                 (* End addition ------------------------------------------ *)
                 showmsg(13);
               END;
           END;
      END;
    END;

PROCEDURE RcvData;

var
  i : INTEGER;
  bte : byte;

  BEGIN
    getpack;
    CASE ptype OF
      DT : BEGIN
           FOR i := 1 to pklen DO
             BEGIN
             bte := ORD(pkbuff[i]);
             write(pkfile^,bte);
             END;
           xfercnt := xfercnt + pklen;
           showbytes;
           state := RD;
           END;
      EF : BEGIN
           close(pkfile^);
           xferok := TRUE;
           showmsg(8);
           xmitstr(ACK + #03);
           state := RH;
           END;
      CN : state := C;
      TX : disppacket;
      ELSE BEGIN
           state := Abort;
           IF (ptype = TM) THEN showmsg(12)
             ELSE
               BEGIN;
                 (* Next lines added by AA4RE for better error explaination *)
                 STR(ORD(ptype), work_string);
                 work_string := 'YAPP Rcvdata (' + work_string + ')';
                 set_dollar1_parm (@work_string);
                 (* End addition ------------------------------------------ *)
                 showmsg(13);
               END;
           END;
      END;
    END;

PROCEDURE Cancel;

  BEGIN
    xmitstr(CAN + #00);
    state := CW;
  END;

PROCEDURE CanWait;

  BEGIN
    escmsg(10);
    getpack;
    CASE ptype OF
      CA : state := Start;
      CN : xmitstr(ACK + #05);
      TM : state := Start;
      UK : state := Start;
      TX : disppacket;
      else;
    END;
  END;


PROCEDURE CanRecd;

var
  i : INTEGER;
  bte : byte;

  BEGIN
    showmsg(11);
    xmitstr(ACK + #05);
    yapp_delay(3000);   {see IF this helps the stupid TNC-2s problem!}
    state := Start;
  END;

PROCEDURE xfer;

begin
  xferhdr := '';
  xfercnt := 0;
  xmitline('t');   {put TNC into transparent mode}
  yapp_delay(50);
  txtbuff := '';
  REPEAT
    showstate;     {display state}
    CASE state OF
      S: Sendinit;
     S1: Sendinit_retry;
     SH: Sendhdr;
     SD: Senddata;
     SE: SendEOF;
     ST: SendEOT;
      R: Receive;
     RH: Rcvhdr;
     RD: Rcvdata;
  Abort: Cancel;
     CW: CanWait;
      C: CanRecd;
    else;
    END; {case}
  UNTIL (state = Start);

  write(#07);     {bell}
  yapp_delay(1000);    {give TNC some time}
  cmdmode;        {get into command mode}
  flush;
  xmitline('conv');  {back to converse mode}
end;

PROCEDURE yapp_download;

  BEGIN

    show_xmit_count := 3;

    ASSIGN(pkfile^, pkfname);

    FILEMODE := 0;
    RESET(pkfile^);
    FILEMODE := 2;

    free_semaphore(semaphore_interrupts);

    set_binary_switch(TRUE);

    state := S;
    xfer;

    set_binary_switch(FALSE);

  END;

PROCEDURE yapp_upload;

  VAR
    i : INTEGER;

  BEGIN

    ASSIGN(pkfile^, pkfname);
    REWRITE(pkfile^);

    free_semaphore(semaphore_interrupts);

    set_binary_switch(TRUE);

    state := R;
    xfer;

    set_binary_switch(FALSE);

  END;